;;; The box & arrow tree view
(defpackage :tree-view
  (:use :cl :boxes.util :diagram)
  (:nicknames :tv)
  (:export :basic-tree-view
           :tree-view
           :refresh-tree))

(in-package :tree-view)

(defclass basic-tree-view (dtm:draw-tree-mixin)
  ()
  (:documentation "For spacing boxes without dragging all the other
luggage from tree-view"))

(defclass tree-view (basic-tree-view)
  ())

;; only the width and height are filled in for arguments. The location
;; is set by the parent.

(defmethod space-node ((arg argument) (diagram basic-tree-view))
  (multiple-value-bind (w h) (argument-content-size arg diagram)
    (setf (geom:width arg) (if (quantity arg)
                               (max (+ w (* 2 (arg-margin diagram)))
                                    (min-arg-width diagram))
                               (min-arg-width diagram))
          (geom:height arg) (+ h (* 2 (arg-margin diagram))))))

(defmethod space-node ((arg multi-input-argument) (diagram basic-tree-view))
  (multiple-value-bind (w h) (argument-content-size arg diagram)
    (setf (geom:width arg) (if (quantity arg)
                               (max w
                                    (* (input-argument-num-fields arg) (min-arg-width diagram)))
                               (* (input-argument-num-fields arg) (min-arg-width diagram)))
          (geom:height arg) (+ h (* 2 (arg-margin diagram))))))

(defmethod space-node :before ((root box) (diagram basic-tree-view))
  "All boxes need to have their height set. Right now all boxes are the same height."
  (setf (geom:width root) (min-box-width diagram)
	(geom:height root) (max (+ (apply 'max (or (mapcar 'geom:height (tree:children root)) '(0)))
                                   (* (box-margin diagram) 2))
                                (min-box-height diagram))))

(defun center-boxes (root boxes diagram)
  (labels ((right-align (box x)
             (move-tree box
                        (- x
                           (- (geom:x (tree-dimensions box t))
                              (- (geom:x box)
                                 (geom:x (tree-coordinates box t))))
                           (truncate (hpadding diagram) 2))
                        (geom:y box)
                        t))
           (left-align (box x)
             (move-tree box
                        (+ x
                           (- (geom:x box)
                              (geom:x (tree-coordinates box t)))
                           (truncate (hpadding diagram) 2))
                        (geom:y box)
                        t)))
    (let ((singles (remove-if 'multiparent-box-p boxes))
          (multis (remove-if-not 'multiparent-box-p boxes)))
      (cond
        ((and (= (length singles) 1)
              (or (null multis)
;;                   (and (leaf-box-p (first singles))
;;                        (multiparent-on-single-level-p multis))
                  ))
         ;;(print `(beeeer ,(mapcar 'childq boxes)))
         (move-tree (first singles) (+ (geom:x root)
                                       (truncate (- (geom:width root)
                                                    (geom:width (first singles)))
                                                 2))
                    0))
        ((and (= (length singles) 1)
              (= (length multis) 1))
         ;;(print `(single ,(childq (first singles))))
         (let ((center (+ (geom:x root) (truncate (geom:width root) 2))))
           (if (multiparent-box-p (first boxes))
               (left-align (first singles) center)
               (right-align (first singles) center))))
        (t
         (let ((total-width (+ (reduce '+ singles :key (lambda (b) (geom:x (tree-dimensions b t))))
                               (* (1- (length singles)) (hpadding diagram)))))
           (loop
              for x = (+ (geom:x root)
                         (truncate (- (geom:width root) total-width)
                                   2))
              then (+ x (geom:x (tree-dimensions i t)) (hpadding diagram))
              for i in singles 
              do (move-tree i (+ x (- (geom:x i) (geom:x (tree-coordinates i t)))) 0))))))))

(defmethod arrange-child-boxes ((root box) (diagram tree-view))
  ;; arrange child boxes
  (let ((boxes (loop for i in (tree:children root) when (tree:children i) append (tree:children i))))
    (dolist (i boxes) (move-tree-up i diagram))
    (if (and (> (length boxes) 1)
             (eql (loop for i in boxes count (leaf-box-p i)) 1)
             (or (normal-leaf-box-p (first boxes))
                 (normal-leaf-box-p (car (last boxes))))
             (notany 'multiparent-box-p boxes))
        (if (normal-leaf-box-p (first boxes))
            (progn
              ;;(print `(monkey ,(childq (second boxes))))
              (center-boxes root (cdr boxes) diagram)
              (move-tree-left (first boxes) diagram (+ (geom:width (first boxes)) (hpadding diagram))))
            (progn
              ;;(print `(heerpo ,(childq (first boxes))))
              (center-boxes root (butlast boxes) diagram)
              (move-tree (car (last boxes)) (+ (geom:right (car (last boxes 2))) (hpadding diagram)) 0)))
        (progn
          ;;(print `(fertinboo ,(mapcar 'childq boxes)))
        (center-boxes root boxes diagram))))  )

(defun arrange-arguments (root diagram)
  ;; FIXME: we gotta calculate this twice which sucks
  (let ((arg-width (+ (reduce '+ (tree:children root) :key 'geom:width)
                      (* (1- (length (tree:children root))) (arg-padding diagram)))))
    ;; place args
    (loop
       for x = (+ (geom:x root)
                  (max (box-margin diagram)
                       (truncate (- (geom:width root) arg-width) 2)))
       then (+ x (geom:width i) (arg-padding diagram))
       for i in (tree:children root) do
       (setf (geom:x i) x
             (geom:y i) (+ (geom:y root) (box-margin diagram))))))

(defmethod space-node ((root multi-argument-box) (diagram basic-tree-view))
  (let ((arg-width (+ (reduce '+ (tree:children root) :key 'geom:width)
                      (* (1- (length (tree:children root))) (arg-padding diagram)))))
    ;; figure out the width
    (setf (geom:width root) (max (+ arg-width
                                    (* 2 (box-margin diagram)))
                                 (min-box-width diagram)))
    (arrange-arguments root diagram)))

(defmethod space-node :after ((root invisible-node) (diagram basic-tree-view))
  (setf (geom:height root) 0
        (geom:width root) 0))

(defun refresh-tree (view align &optional align-y)
  (setf (d:gravity view) align
        (d:guide view) align-y)
  (update-diagram-view view))

(defun display-tree (tree)
  (gwee:with-gui (1024 768 :font "sans.ttf" :background (gwee:gray 255) :foreground (gwee:gray 0))
    (let ((v (make-instance 'tree-view
                            :width 1024 :height 764
                            :parent gwee:*top-view*)))
      (setf (root v) tree)
      (d:update-diagram-view v))))
